home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Web Browse262539102001.psc / Form1.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2001-08-19  |  10.8 KB  |  304 lines
  1. VERSION 5.00
  2. Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
  3. Begin VB.Form Form1 
  4.    Caption         =   "Form1"
  5.    ClientHeight    =   2685
  6.    ClientLeft      =   60
  7.    ClientTop       =   315
  8.    ClientWidth     =   4170
  9.    LinkTopic       =   "Form1"
  10.    ScaleHeight     =   2685
  11.    ScaleWidth      =   4170
  12.    StartUpPosition =   3  'Windows Default
  13.    Begin VB.CommandButton Command1 
  14.       Caption         =   "?"
  15.       BeginProperty Font 
  16.          Name            =   "MS Sans Serif"
  17.          Size            =   9.75
  18.          Charset         =   0
  19.          Weight          =   700
  20.          Underline       =   0   'False
  21.          Italic          =   0   'False
  22.          Strikethrough   =   0   'False
  23.       EndProperty
  24.       Height          =   375
  25.       Left            =   3525
  26.       TabIndex        =   4
  27.       Top             =   2265
  28.       Width           =   465
  29.    End
  30.    Begin VB.ListBox List2 
  31.       Height          =   1815
  32.       Left            =   2205
  33.       TabIndex        =   2
  34.       Top             =   390
  35.       Width           =   1875
  36.    End
  37.    Begin VB.ListBox List1 
  38.       Height          =   1815
  39.       Left            =   120
  40.       TabIndex        =   0
  41.       Top             =   360
  42.       Width           =   1965
  43.    End
  44.    Begin MSWinsockLib.Winsock wServer 
  45.       Index           =   0
  46.       Left            =   795
  47.       Top             =   2220
  48.       _ExtentX        =   741
  49.       _ExtentY        =   741
  50.       _Version        =   393216
  51.    End
  52.    Begin MSWinsockLib.Winsock wListen 
  53.       Left            =   270
  54.       Top             =   2250
  55.       _ExtentX        =   741
  56.       _ExtentY        =   741
  57.       _Version        =   393216
  58.    End
  59.    Begin VB.Label Label1 
  60.       Caption         =   "Index | Streaming Clients"
  61.       Height          =   240
  62.       Index           =   1
  63.       Left            =   2205
  64.       TabIndex        =   3
  65.       Top             =   75
  66.       Width           =   1920
  67.    End
  68.    Begin VB.Label Label1 
  69.       Caption         =   "Index | Request Log"
  70.       Height          =   240
  71.       Index           =   0
  72.       Left            =   150
  73.       TabIndex        =   1
  74.       Top             =   120
  75.       Width           =   1920
  76.    End
  77. Attribute VB_Name = "Form1"
  78. Attribute VB_GlobalNameSpace = False
  79. Attribute VB_Creatable = False
  80. Attribute VB_PredeclaredId = True
  81. Attribute VB_Exposed = False
  82. Private Sub Command1_Click()
  83.     'read the read me :D
  84.     Shell "notepad " & App.path & "\readme.txt", vbNormalFocus
  85. End Sub
  86. Private Sub Form_Load()
  87.     DebugFlag = True 'turns on messages to debug.print
  88.     ReDim user(0)
  89.     wListen.LocalPort = 80
  90.     wListen.Listen
  91.     hdrOK = br("HTTP/1.1 200 OK\nContent-Type: text/html\nConnection: Close\n\n")
  92.     ie = "C:\Program Files\Internet Explorer\IEXPLORE.EXE"
  93.     If FileExists(ie) Then
  94.         Shell ie & " http://localhost/", vbNormalFocus
  95.     End If
  96. End Sub
  97. Private Sub wListen_ConnectionRequest(ByVal requestID As Long)
  98.     X = -1
  99.     For i = 1 To wServer.UBound
  100.         If wServer(i).State <> sckConnected And _
  101.            wServer(i).State <> sckConnecting And _
  102.            wServer(i).State <> sckConnectionPending Then
  103.            '------
  104.            X = i
  105.            Exit For
  106.         End If
  107.     Next
  108.     If X < 1 Then X = wServer.UBound + 1: Load wServer(X)
  109.     wServer(X).Close
  110.     wServer(X).accept requestID
  111. End Sub
  112. Private Sub wServer_DataArrival(index As Integer, ByVal bytesTotal As Long)
  113.     Dim s As String
  114.     Dim h As HTTPRequest
  115.     wServer(index).GetData s, vbString
  116.     h = ParseRequest(s, wServer(index).RemoteHostIP)
  117.     'Call DebugHttpHeader(s)
  118.     If h.page = Empty Then h.page = "login.html"
  119.     db "Request for " & LCase(h.page) & " Assigned index " & index
  120.     List1.AddItem index & " - " & h.ip & " " & h.page
  121.     Select Case LCase(h.page)
  122.         Case "login.html"
  123.             HTTP.ServeFile wServer(index), App.path & "\login.html"
  124.             WaitForSentAndClosed index
  125.         Case "frames.html"
  126.             login = LoginUser(h)
  127.             db "prelogin was " & login & " (-1 means failure)"
  128.             If login <> -1 Then
  129.                 HTTP.ServeFrames wServer(index), login
  130.             Else
  131.                 HTTP.ServeFile wServer(index), App.path & "\sorry.html"
  132.             End If
  133.             WaitForSentAndClosed index
  134.         Case "banner.html"
  135.             db "Serving up banner!"
  136.             HTTP.ServeBanner2 wServer(index), h
  137.             WaitForSentAndClosed index
  138.             If Len(h.qryStr) > 0 Then Call PostChat(h)
  139.         Case "body.html"
  140.            i = GetUserIndex(h)
  141.            db "Users personal index set to " & i & " (only > 0 is valid)"
  142.            If i > 0 Then
  143.                 user(i).index = index
  144.                 HTTP.InitalizeBody wServer(index)
  145.                 WaitForSendComplete index
  146.                 List2.AddItem index & " - " & h.ip & " " & h.arg(0)
  147.            Else
  148.                 HTTP.Redirect_ wServer(index), "\login.html"
  149.                 WaitForSentAndClosed index
  150.                 db "Redirected to login because on invalid user id"
  151.            End If
  152.         Case Else:
  153.             db "Oops couldnt find page " & h.page & " for " & h.ip
  154.             wServer(index).SendData hdrOK & "<html><h1>Opps cant find your page!"
  155.             WaitForSentAndClosed index
  156.     End Select
  157. End Sub
  158. Private Function ParseRequest(X, ip) As HTTPRequest
  159.     Dim h As HTTPRequest
  160.     s.Strng = Trim(X)
  161.     h.ip = ip
  162.     h.method = s.SubstringToChar(1, " ")
  163.     fsp = s.IndexOf(" ") + 2         'first space
  164.     ssp = s.NextIndexOf              'second space
  165.     h.page = s.Substring(fsp, ssp)   'page request
  166.     s.Strng = h.page
  167.     qs = s.IndexOf("?")
  168.        
  169.     If qs > 0 Then
  170.         h.page = s.SubstringToChar(1, "?")
  171.         h.qryStr = s.ToEndOfStr(qs + 1)
  172.         h.arg() = Split(h.qryStr, "&")
  173.     End If
  174.        
  175.     'Debug.Print "method=" & h.method & vbCrLf & _
  176.     '            "page=" & h.page & vbCrLf & _
  177.     '            "args=" & Join(h.arg, ",") & vbCrLf & _
  178.     '            "userA=" & h.uAgent
  179.     ParseRequest = h
  180. End Function
  181. Private Function LoginUser(t As HTTPRequest) As Integer
  182.    'only set user(i).index with streaming body.html
  183.    'passes back userindex if successful.. -1 if failed
  184.    'test is based on parsed name so html differences dont matter
  185.     fuser = ary.StrFindValFromKey(t.arg, "USER")
  186.     says = ary.StrFindValFromKey(t.arg, "SAYS")
  187.     pName = html.ParseAll(fuser)
  188.     For i = 1 To UBound(user)
  189.         If user(i).pName = pName Then LoginUser = -1: Exit Function
  190.     Next
  191.     ReDim Preserve user(UBound(user) + 1)
  192.         
  193.     ub = UBound(user)
  194.     With user(ub)
  195.         .ip = t.ip
  196.         .fName = fuser
  197.         .says = says
  198.         .pName = pName
  199.     End With
  200.     LoginUser = ub
  201. End Function
  202. Private Sub PostChat(h As HTTPRequest)
  203.     whoto = ary.StrFindValFromKey(h.arg, "WHOTO")
  204.     acton = ary.StrFindValFromKey(h.arg, "ACTION")
  205.     says = ary.StrFindValFromKey(h.arg, "SAYS") & "<br>"
  206.     fuser = ary.StrFindValFromKey(h.arg, "USER")
  207.     time_ = Mid(Time, 1, 8)
  208.     n = "<br></a>(" & time_ & ") " & fuser & " "
  209.     n = n & acton & " " & whoto & " : " & says & vbCrLf
  210.     'If InStr(acton, "whisper") >= 0 Then 'private post
  211.         'find user index from whoto
  212.         'post to talking user and post to user(i).index
  213.     'else
  214.         n = HTTP.Escape(n)
  215.         db "Chat to post: " & n
  216.         For i = 1 To UBound(user)
  217.             X = user(i).index
  218.             db "testing user " & i & " for valid chat frame with value'" & X & "'"
  219.             If Len(X) > 0 And X > 0 Then
  220.                 If wServer(X).State = sckConnected Then
  221.                     wServer(X).SendData n & vbCrLf
  222.                     WaitForSendComplete X
  223.                     db "user " & i & " is valid with index " & X
  224.                 Else
  225.                     With user(i)
  226.                         .ip = Empty: .fName = Empty: .pName = Empty: .index = Empty
  227.                     End With
  228.                     wServer(X).Close
  229.                 End If
  230.             End If
  231.         Next
  232.     'end if
  233. End Sub
  234. Private Sub wServer_SendComplete(index As Integer)
  235.     db "Index " & index & " Send Complete"
  236.     If Not ReadyToClose Then
  237.         wServer(index).Close
  238.         ReadyToClose = True
  239.         db "Index " & index & " has been closed"
  240.     ElseIf Not ReadyToReturn Then
  241.         ReadyToReturn = True
  242.         db "Index " & index & " ready to return : D"
  243.     End If
  244. End Sub
  245. Function WaitForSentAndClosed(index)
  246.     ReadyToClose = False
  247.     db "Index " & index & " is awaiting close verification"
  248.     While Not ReadyToClose
  249.         DoEvents: DoEvents: DoEvents: DoEvents
  250.     Wend
  251.     db "Index " & index & " Has been verified as closed"
  252. End Function
  253. Function WaitForSendComplete(index)
  254.     ReadyToClose = True
  255.     ReadyToReturn = False
  256.     db "Execution paused until Index " & index & " returns"
  257.     While Not ReadyToReturn
  258.         DoEvents: DoEvents: DoEvents: DoEvents
  259.     Wend
  260.     db "Index " & index & " has returned...execution may proceede"
  261. End Function
  262. 'Private Sub wServer_SendComplete(index As Integer)
  263. '    db "Index " & index & " Send Complete"
  264. '    'should probably switch these two arrays over to comma
  265. '    'delimited strings and do a string search, because i cant
  266. '    'skinny these arrays cause it causes weird errors with
  267. '    'this event firing at the remote browsers whim
  268. '    If Not AryIsEmpty(CloseAfterSend) Then
  269. '        For i = 0 To UBound(CloseAfterSend)
  270. '            If CloseAfterSend(i) = index Then
  271. '                wServer(index).Close
  272. '                CloseAfterSend(i) = ""
  273. '                db "Index " & index & " Has been closed"
  274. '            End If
  275. '        Next
  276. '     End If
  277. '     If Not AryIsEmpty(WaitUntilSent) Then
  278. '        For i = 0 To UBound(WaitUntilSent)
  279. '            If WaitUntilSent(i) = index Then
  280. '                WaitUntilSent(i) = ""
  281. '                db "Index " & index & " Has been completed send..ready to resume"
  282. '            End If
  283. '        Next
  284. '     End If
  285. 'End Sub'
  286. 'Function WaitForSentAndClosed(index)
  287. '    push CloseAfterSend(), index
  288. '    db "Index " & index & " is awaiting verification"
  289. '    i = UBound(CloseAfterSend)
  290. '    While CloseAfterSend(i) <> ""
  291. '        DoEvents: DoEvents: DoEvents: DoEvents
  292. '    Wend
  293. '    db "Index " & index & " Has been verified as closed"
  294. 'End Function
  295. 'Function WaitForSendComplete(index)
  296. '    push WaitUntilSent(), index
  297. '    db "Execution paused until Index " & index & " returns"
  298. '    i = UBound(WaitUntilSent)
  299. '    While WaitUntilSent(i) <> ""
  300. '        DoEvents: DoEvents: DoEvents: DoEvents
  301. '    Wend
  302. '    db "Index " & index & " has returned...execution may proceede"
  303. 'End Function
  304.